Revista CD Expert 8/Revista CD Expert nº 08 CD1.iso/Utilitarios/Internet/WebExpress/wbx32.exe/MVFORMS.CGI

Text File | 1998-01-01 | 16.5 KB | 648 lines

#!/usr/local/bin/perl
#the perl path may need to be set if your web host is running Un*x

require 5.0;

#the path to the sendmail program will need to be set on Un*x systems
$mail_program = "/usr/lib/sendmail -t";

#on NT the name of the smtp server must be set
$smtp_server = "smtp.surething.com";

use Env;

# turn off output buffering for AnaServe - effect unknown Patrick 10/21/98
$| = 1;

##########################################################################
#
#    MVForms.cgi - A form response script for use with WebExpress.
#    Copyright 1997 MicroVision Development, Inc.
#
#    Version 3.00    Sep 29 1998
#            3.01    Oct 22 1998 - Unix sendmail version had inverted to and from addresses.
#                                - Removed all extraneous whitespace and reformated with
#                                  spaces rather than tabs.
#                                - Modified .thanks_url processing to allow it to be set to either
#                                  a complete URL, or a file name relative to the directory
#                                  containing the form page.
#
#    Special thanks to Selena Sol and Sanford Morton
#    for examples and explanations. Thanks to William Mussatto
#    for posting the sendmail.pl script on the Win32-Perl-Web list,
#    and to C. Mallwitz for writing it.
#
#    Permission is granted to use, modify and distribute
#    this script, so long as this copyright section is
#    included intact.
#
#
#    This script gives the option of using Un*x sendmail on systems that
#    have it available. To use the perl sendmail that is built in
#    access to an SMTP server is required.
#
############################################################################

# Instructions page
# Used if the page owner forgets to supply .email_target hidden tag
#$instructions_url = "http://www.halcyon.com/sanford/cgi/web2mail/index.html";

#
# Program Begins Here
#

# parse the form data
&ReadParse;


#
# Check required fields were filled by the user
#
if ($in{'.required'})
{
    &Compulsory;
}

if ( ! $in{'.intro'} )
{
    &usage("the intro for the response (<I>.intro</I>)");
}

#
# set the current date
#
$current_date = &get_date;

#
# if it is a redirect menu, jump
#
if ( $in{'.form_type'} eq "jump" )
{
    &jump_url;
}

#
# Otherwise, send an email response
#

#
# Check for required hidden fields
#
if ( !$in{'.email_dest'} )
{
    &usage("the email desitination field (<I>.email_dest</I>)");
}

if ( ! $in{'.intro'} )
{
    &usage("the intro for the response (<I>.intro</I>)");
}

if ( ! $in{'.subject'} )
{
    &usage("the subject for the response (<I>.subject</I>)");
}

#
# send the response
#
&send_response;

#
# Redirect to acknowledgement page
#
&send_acknowledgement;

exit;

######################################
# Parse the cgi form data.
# Adapted from cgi-lib.pl by [e-mail]
# Copyright 1994 Steven E. Brenner
#
sub ReadParse
{
    local (*in) = @_ if @_;

    if ( $ENV{'REQUEST_METHOD'} eq "GET" )
    {
        # replaced his MethGet function
        ## don't accept GET, to make it a little harder to spoof the script
        print "Content-type: text/html\n\n";
        print "Sorry, this script only accepts METHOD=POST. ";
        print "Use that inside your <FORM ...> tag";
        exit;
    }
    elsif ($ENV{'REQUEST_METHOD'} eq "POST")
    {
        read(STDIN,$in,$ENV{'CONTENT_LENGTH'});
    }
    else
    {
        # Added for command line debugging
        # Supply name/value form data as a command line argument
        # Format: name1=value1\&name2=value2\&... (need to escape & for shell)
        # Find the first argument that's not a switch (-)
        $in = ( grep( !/^-/, @ARGV )) [0];
        $in =~ s/\\&/&/g;
    }
    @in = split(/&/,$in);

    foreach $i (0 .. $#in)
    {
        # Convert plus's to spaces
        $in[$i] =~ s/\+/ /g;

        # Split into key and value.
        ($key, $val) = split(/=/,$in[$i],2); # splits on the first =.

        # Convert %XX from hex numbers to alphanumeric
        $key =~ s/%(..)/pack("c",hex($1))/ge;
        $val =~ s/%(..)/pack("c",hex($1))/ge;

        # Associate key and value
        # \0 is the multiple separator
        $in{$key} .= "\0" if (defined($in{$key}));
        $in{$key} .= $val;
   }
   return length($in);
}

############################
#
# sub Compulsory
#
# Check that the fields in the form that are required to be
# filled are filled. Compulsory fields are listed in the
# .required hidden field, semi-colon separated.

sub Compulsory
{
    #split them out of the list in the value field
    @required = split (/;/, $in{'.required'});

    #check that each required field name keys to data in the input hash
    foreach $elem (@required)
    {
        foreach $key (keys %in)
        {
            next if ($key ne $elem);

            #the required field and the key match, so check that there is data
            if (!$in{$elem})
            {
                $printkey = $elem;
                $printkey =~ s/^..//;
                $error .= ("<li>The $printkey field must be filled.<p>\n");
            }
        }
    }

    if ($error)
    {
        #kick them to a page telling them what was blank
        #use back button to get back to the form.

        #******************** CUSTOMIZABLE TEXT ********************
        $error_page  = "Content-type: text/html\n\n";
        $error_page .= "<head><TITLE>Form Entries Incomplete or Invalid</TITLE></head>\n<body><p>\n";
        $error_page .= "<hr>\n<H3>Form Entries Incomplete or Invalid</H3>\n";
        $error_page .= "One or more problems exist with the data you have entered.<UL>\n";
        $error_page .= $error;
        $error_page .= "</UL>Please use the <I>Back</I> button on your web browser to problems.<P><HR></BODY></HTML>";

    print $error_page;
    exit;
    }
}
######################################
# general usage routine
#
sub usage
{
    my ($usage_error) = @_;

    $usage_body  = "Content-type: text/html\n\n";
    $usage_body .= "<H2> Form Processing Error </H2>";
    $usage_body .= "<TITLE> Form Processing Error </TITLE>";
    $usage_body .= "You have forgotten to include <B>$usage_error</B> in your form. ";
    $usage_body .= "Please correct the problem in your form, and try again. ";
    $usage_body .= "<P>The following fields were included in your form: <OL>";

    foreach (keys %in)
    {
        $usage_body .= "<LI>$_: $in{$_}\n";
    }

    $usage_body .= "</OL>Press the <B>BACK</B> button to return to the submitting form.";

    print $usage_body;
    exit;
}
######################################
sub get_date
{
    $current_century = 20;

    @days = ('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday');

    @months = ('January','February','March','April','May','June','July','August','September','October','November','December');

    ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);

    if ($hour < 10)
    {
        $hour = "0$hour";
    }

    if ($min < 10)
    {
        $min = "0$min";
    }

    if ($sec < 10)
    {
        $sec = "0$sec";
    }

    $year = ($current_century-1) . "$year";
    $date = "$days[$wday], $months[$mon] $mday, $year at $hour\:$min\:$sec";

    return $date;
}

######################################
#    jump to URL destination
#
sub jump_url
{
    # look for destination field
    foreach (keys %in)
    {
        next if /^\./;  # skip hidden form data in mail message

        if ( $_ eq "Destination" )
        {
            $dest = $in{$_};
        }
    }

    # could check destination here
    print "Location: $dest\n\n";
    exit;
}

######################################
# send repsonse
#
sub send_response
{
    $email_body = $in{'.intro'} ? "$in{'.intro'}\n\n" : "The following data has been submitted:\n\n";

    # added functionality to allow users to specify fields and order using the
    # .remove_indexing key and the .response_order hidden field.
    if (!$in{'.remove_indexing'} and $in{'.response_order'})
    {
        # split them out of the list in the value field
        @resp_ordr = split (/;/, $in{'.response_order'});

        foreach    $ro_elem (@resp_ordr)
        {
            # format the text and add it to the mail message
            $form_name = &format_text_field("$ro_elem:");

            $item = "$form_name $in{$ro_elem}";

            # if multiple values, indent them on new lines
            $item =~ s/\0/"\n\t".(" "x(2+length($_)))/ge;

            $email_body .= "\t $item \n";

            # grab the mail address and save it
            if ($ro_elem =~ /.*(email).*|.*(e-mail).*/i)
            {
                $client_email = $in{$ro_elem};
            }
        }
    }
    else
    {
        foreach (sort keys %in)
        {
            # skip fields beginning with a period (hidden fields)
            next if /^\./;

            # save client email for return address
            if ( $_ eq "zzClientEmail" )
            {
                $client_email = $in{$_};
            }

            # don't list the send and clear buttons
            if ( $_ eq "xxSend" )
            {
                next;
            }

            if ( $_ eq "xxClear" )
            {
                next;
            }

            $form_name = &format_text_field("$_:");
            $item = "$form_name $in{$_}";

            if ( $in{'.remove_indexing'} )
            {
                $item =~ s/^..//;
            }

            # if multiple values, indent them on new lines
            $item =~ s/\0/"\n\t".(" "x(2+length($_)))/ge;

            $email_body .= "\t $item \n";
        }
        $flag = "did case two<br>\n";
    }

    #******************** CUSTOMIZABLE TEXT ********************
    $email_body .= "<br>\nSubmitted on: $current_date";
    $email_body .= "<br>\nForm page: $ENV{HTTP_REFERER}";
    $email_body .= "<br>\nUser address: $ENV{REMOTE_ADDR}";
    $email_body .= "<br>\nUser host: $ENV{REMOTE_HOST}";

    $in{'.email_dest'} =~ s/,.*//;

    # to and from addresses are flipped between the NT and Unix versions
    # here Patrick 10/21/98
    if ($ENV{OS} eq "Windows_NT")
    {
        &sendmail($client_email,$client_email,$in{'.email_dest'},$smtp_server,$in{'.subject'},$email_body);
    }
    else
    {
        &send_mail ($client_email,$in{'.email_dest'},$in{'.subject'},$email_body);
    }
}

#####################################
sub format_text_field
{
    my ($value) = @_;

    return($value . substr((" " x 25), length($value)));
}

#---------------------------------------------------------------------------
# sub sendmail()
# Modified 10-20-1997 to not send blank fields.
#
# send/fake email around the world ...
#
# Version : 1.21
# Environment: Hip Perl Build 105 NT 3.51 Server SP4
# Environment: Hip Perl Build 110 NT 4.00
#
# arguments:
#
# $from email address of sender
# $reply email address for replying mails
# $to email address of reciever
# (multiple recievers can be given separated with space)
# $smtp name of smtp server (name or IP)
# $subject subject line
# $message (multiline) message
#
# return codes:
#
# 1 success
# -1 $smtphost unknown
# -2 socket() failed
# -3 connect() failed
# -4 service not available
# -5 unspecified communication error
# -6 local user $to unknown on host $smtp
# -7 transmission of message failed
# -8 argument $to empty
#
# usage examples:
#
# print
# sendmail("Alice <alice\@company.com>",
# "alice\@company.com",
# "joe\@agency.com charlie\@agency.com",
# $smtp, $subject, $message );
#


# or
#
# print
# sendmail($from, $reply, $to, $smtp, $subject, $message );
#
# (sub changes $_)
#
#------------------------------------------------------------1;

use Socket;
use IO::Handle;

sub sendmail
{
    ($from, $reply, $to, $smtp, $subject, $message) = @_;

    $fromaddr = $from;
    $replyaddr = $reply;

    $to =~ s/[ \t]+/, /g; # pack spaces and add comma
    $fromaddr =~ s/.*<([^\s]*?)>/$1/; # get from email address
    $replyaddr =~ s/.*<([^\s]*?)>/$1/; # get reply email address
    $replyaddr =~ s/^([^\s]+).*/$1/; # use first address
    $message =~ s/^\./\.\./gm; # handle . as first character
    $message =~ s/\r\n/\n/g; # handle line ending
    $message =~ s/\n/\r\n/g;
    $smtp =~ s/^\s+//g; # remove spaces around $smtp
    $smtp =~ s/\s+$//g;

    if (!$to)
    {
    return(-8);
    }

    $proto = (getprotobyname('tcp'))[2];
    $port = (getservbyname('smtp', 'tcp'))[2];

    $smtpaddr = ($smtp =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/) ? pack('C4',$1,$2,$3,$4) : (gethostbyname($smtp))[4];

    if (!defined($smtpaddr))
    {
        return(-1);
    }

    if (!socket(S, AF_INET, SOCK_STREAM, $proto))
    {
        return(-2);
    }

    if (!connect(S, pack('Sna4x8', AF_INET, $port, $smtpaddr)))
    {
        return(-3);
    }

    S->autoflush(1);

    $_ = <S>;
    if (/^[45]/)
    {
        close(S);
        return(-4);
    }

    print S "helo localhost\r\n";
    $_ = <S>;
    if (/^[45]/)
    {
        close(S);
        return(-5);
    }

    print S "mail from: <$fromaddr>\r\n";
    $_ = <S>;
    if (/^[45]/)
    {
        close(S);
        return(-5);
    }

    foreach (split(/, /, $to))
    {
        print S "rcpt to: <$_>\r\n";
        $_ = <S>;
        if (/^[45]/){
        close(S);
        return(-6);
        }
    }

    print S "data\r\n";
    $_ = <S>;
    if (/^[45]/)
    {
        close S;
        return(-5);
    }

    print S "To: $to\r\n";
    print S "From: $from\r\n";
    print S "Reply-to: $replyaddr\r\n" if $replyaddr;
    print S "X-Mailer: Perl Sendmail Version 1.21\r\n";
    print S "Subject: $subject\r\n\r\n";
    print S "$message";
    print S "\r\n.\r\n";

    $_ = <S>;

    if (/^[45]/)
    {
        close(S);
        return(-7);
    }

    print S "quit\r\n";
    $_ = <S>;

    close(S);
    return(1);
}

######################################
# send mail containing the form data
#
sub send_mail
{
    my ($clnt_email, $email_dst, $subject, $message) = @_;    # list assignment

    if ( !open(MAIL, "|$mail_program") )
    {
        &print_error_page;
        exit;
    }
    print MAIL <<__END_OF_MAIL__;
To: $email_dst
From: $clnt_email
Subject: $subject

$message

__END_OF_MAIL__

    close (MAIL);
}

######################################
# mail open error message
#
sub print_error_page
{
    #******************** CUSTOMIZABLE TEXT ********************
    $error_page  = "Content-type: text/html\n\n";
    $error_page .= "<TITLE> System Error </TITLE>";
    $error_page .= "<H2> System Error </H2>";
    $error_page .= "The system is not responding, and the form could not be processed. ";
    $error_page .= "Please try again later.";
    $error_page .= "<P>Thank you for taking the time to fill out the form. ";
    $error_page .= "Sorry for the inconvenience!";

    if ( $in{'.back_to_url'} )
    {
        $error_page .= "<P>Return to <A HREF=\"$in{'.back_to_url'}\">$in{'.back_to_url'}</A>";
    }

    print $error_page;
}

######################################
# Send an acknowledgement
#
sub send_acknowledgement
{
    # Get address of page that we came from and strip page name
    $ENV{'HTTP_REFERER'} =~ m[(.+/)];

    $new_url = $1;

    if ( $in{'.thanks_url'} =~ /http:\/\//)
    {
        print "Location: $in{'.thanks_url'}\n\n";
    }
    elsif ( $in{'.thanks_url'} )
    {
        print "Location: $new_url$in{'.thanks_url'}\n\n";
    }
    else
    {
        &send_thanks_page;
    }
}

######################################
# generic acknowledgement page
#
sub send_thanks_page
{
    #******************** CUSTOMIZABLE TEXT ********************
    $thanks_page  = "Content-type: text/html\n\n";
    $thanks_page .= "<TITLE>Form Acknowledgement</TITLE>";
    $thanks_page .= "<H2>Thank You</H2>";
    $thanks_page .= "Your information has been submitted to ";
    $thanks_page .= "<A HREF=\"mailto:$in{'.email_dest'}\">$in{'.email_dest'}</A>.<p>\n";
    $thanks_page .= "Thank you for taking the time to fill out the form!<br>\n";
    #$thanks_page .= "Perl Version = $] <br>\n";

    if ( $in{'.back_to_url'} )
    {
        $thanks_page .= "<P>Return to <A HREF=\"$in{'.back_to_url'}\">$in{'.back_to_url'}</A>";
    }

    print $thanks_page;
}